home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / ramap.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-15  |  45.8 KB  |  1,934 lines
  1. /* Array mapping functions for APL-Scheme.
  2.    Copyright (C) 1994 Radey Shouman.
  3.    
  4.    This program is free software; you can redistribute it and/or modify
  5.    it under the terms of the GNU General Public License as published by
  6.    the Free Software Foundation; either version 1, or (at your option)
  7.    any later version.
  8.    
  9.    This program is distributed in the hope that it will be useful,
  10.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12.    GNU General Public License for more details.
  13.    
  14.    You should have received a copy of the GNU General Public License
  15.    along with this program; if not, write to the Free Software
  16.    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.    */
  18.  
  19.  
  20.  
  21. #include <stdio.h>
  22. #include "_scm.h"
  23.  
  24.  
  25.  
  26. #ifdef ARRAYS
  27.  
  28. typedef struct
  29. {
  30.   char *name;
  31.   SCM sproc;
  32.   int (*vproc) ();
  33. }
  34. ra_iproc;
  35.  
  36. #define BVE_REF(a, i) ((VELTS(a)[(i)/LONG_BIT] & (1L<<((i)%LONG_BIT))) ? 1 : 0)
  37. #define BVE_SET(a, i) (VELTS(a)[(i)/LONG_BIT] |= (1L<<((i)%LONG_BIT)))
  38. #define BVE_CLR(a, i) (VELTS(a)[(i)/LONG_BIT] &= ~(1L<<((i)%LONG_BIT)))
  39. /* Fast, recycling scm_vector ref */
  40. #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
  41. /* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
  42.  
  43. /* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
  44.    elements of scm_vector operands are not aliased */
  45. #ifdef _UNICOS
  46. #define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
  47. #else
  48. #define IVDEP(test, line) line
  49. #endif
  50.  
  51. /* inds must be a uvect or ivect, no check. */
  52. static sizet 
  53. cind (ra, inds)
  54.      SCM ra, inds;
  55. {
  56.   sizet i;
  57.   int k;
  58.   long *ve = VELTS (inds);
  59.   if (!ARRAYP (ra))
  60.     return *ve;
  61.   i = ARRAY_BASE (ra);
  62.   for (k = 0; k < ARRAY_NDIM (ra); k++)
  63.     i += (ve[k] - ARRAY_DIMS (ra)[k].lbnd) * ARRAY_DIMS (ra)[k].inc;
  64.   return i;
  65. }
  66.  
  67. /* Checker for scm_array mapping functions:
  68.    return values: 4 --> shapes, increments, and bases are the same;
  69.    3 --> shapes and increments are the same;
  70.    2 --> shapes are the same;
  71.    1 --> ras are at least as big as ra0;
  72.    0 --> no match.
  73.    */
  74. int 
  75. scm_ra_matchp (ra0, ras)
  76.      SCM ra0, ras;
  77. {
  78.   SCM ra1;
  79.   scm_array_dim dims;
  80.   scm_array_dim *s0 = &dims;
  81.   scm_array_dim *s1;
  82.   sizet bas0 = 0;
  83.   int i, ndim = 1;
  84.   int exact = 2            /* 4 */ ;    /* Don't care about values >2 (yet?) */
  85.   if IMP
  86.     (ra0) return 0;
  87.   switch TYP7
  88.     (ra0)
  89.       {
  90.       default:
  91.     return 0;
  92.       case tc7_vector:
  93.       case tc7_string:
  94.       case tc7_bvect:
  95.       case tc7_uvect:
  96.       case tc7_ivect:
  97.       case tc7_fvect:
  98.       case tc7_dvect:
  99.       case tc7_cvect:
  100.     s0->lbnd = 0;
  101.     s0->inc = 1;
  102.     s0->ubnd = (long) LENGTH (ra0) - 1;
  103.     break;
  104.       case tc7_smob:
  105.     if (!ARRAYP (ra0))
  106.       return 0;
  107.     ndim = ARRAY_NDIM (ra0);
  108.     s0 = ARRAY_DIMS (ra0);
  109.     bas0 = ARRAY_BASE (ra0);
  110.     break;
  111.       }
  112.   while NIMP
  113.     (ras)
  114.       {
  115.     ra1 = CAR (ras);
  116.     if IMP
  117.       (ra1) return 0;
  118.     switch TYP7
  119.       (ra1)
  120.         {
  121.         default:
  122.           return 0;
  123.         case tc7_vector:
  124.         case tc7_string:
  125.         case tc7_bvect:
  126.         case tc7_uvect:
  127.         case tc7_ivect:
  128.         case tc7_fvect:
  129.         case tc7_dvect:
  130.         case tc7_cvect:
  131.           if (1 != ndim)
  132.         return 0;
  133.           switch (exact)
  134.         {
  135.         case 4:
  136.           if (0 != bas0)
  137.             exact = 3;
  138.         case 3:
  139.           if (1 != s0->inc)
  140.             exact = 2;
  141.         case 2:
  142.           if ((0 == s0->lbnd) && (s0->ubnd == LENGTH (ra1) - 1))
  143.             break;
  144.           exact = 1;
  145.         case 1:
  146.           if (s0->lbnd < 0 || s0->ubnd >= LENGTH (ra1))
  147.             return 0;
  148.         }
  149.           break;
  150.         case tc7_smob:
  151.           if (!ARRAYP (ra1) || ndim != ARRAY_NDIM (ra1))
  152.         return 0;
  153.           s1 = ARRAY_DIMS (ra1);
  154.           if (bas0 != ARRAY_BASE (ra1))
  155.         exact = 3;
  156.           for (i = 0; i < ndim; i++)
  157.         switch (exact)
  158.           {
  159.           case 4:
  160.           case 3:
  161.             if (s0[i].inc != s1[i].inc)
  162.               exact = 2;
  163.           case 2:
  164.             if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
  165.               break;
  166.             exact = 1;
  167.           default:
  168.             if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
  169.               return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
  170.           }
  171.           break;
  172.         }
  173.     ras = CDR (ras);
  174.       }
  175.   return exact;
  176. }
  177.  
  178. static char s_ra_mismatch[] = "array shape mismatch";
  179. int 
  180. scm_ramapc (cproc, data, ra0, lra, what)
  181.      int (*cproc) ();
  182.      SCM data, ra0, lra;
  183.      char *what;
  184. {
  185.   SCM inds, z;
  186.   SCM vra0, ra1, vra1;
  187.   SCM lvra, *plvra;
  188.   long *vinds;
  189.   int k, kmax;
  190.   switch (scm_ra_matchp (ra0, lra))
  191.     {
  192.     default:
  193.     case 0:
  194.       scm_wta (ra0, s_ra_mismatch, what);
  195.     case 2:
  196.     case 3:
  197.     case 4:            /* Try unrolling arrays */
  198.       kmax = (ARRAYP (ra0) ? ARRAY_NDIM (ra0) - 1 : 0);
  199.       if (kmax < 0)
  200.     goto gencase;
  201.       vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
  202.       if IMP
  203.     (vra0) goto gencase;
  204.       if (!ARRAYP (vra0))
  205.     {
  206.       vra1 = scm_make_ra (1);
  207.       ARRAY_BASE (vra1) = 0;
  208.       ARRAY_DIMS (vra1)->lbnd = 0;
  209.       ARRAY_DIMS (vra1)->ubnd = LENGTH (vra0) - 1;
  210.       ARRAY_DIMS (vra1)->inc = 1;
  211.       ARRAY_V (vra1) = vra0;
  212.       vra0 = vra1;
  213.     }
  214.       lvra = EOL;
  215.       plvra = &lvra;
  216.       for (z = lra; NIMP (z); z = CDR (z))
  217.     {
  218.       ra1 = CAR (z);
  219.       vra1 = scm_make_ra (1);
  220.       ARRAY_DIMS (vra1)->lbnd = ARRAY_DIMS (vra0)->lbnd;
  221.       ARRAY_DIMS (vra1)->ubnd = ARRAY_DIMS (vra0)->ubnd;
  222.       if (!ARRAYP (ra1))
  223.         {
  224.           ARRAY_BASE (vra1) = 0;
  225.           ARRAY_DIMS (vra1)->inc = 1;
  226.           ARRAY_V (vra1) = ra1;
  227.         }
  228.       else if (!ARRAY_CONTP (ra1))
  229.         goto gencase;
  230.       else
  231.         {
  232.           ARRAY_BASE (vra1) = ARRAY_BASE (ra1);
  233.           ARRAY_DIMS (vra1)->inc = ARRAY_DIMS (ra1)[kmax].inc;
  234.           ARRAY_V (vra1) = ARRAY_V (ra1);
  235.         }
  236.       *plvra = scm_cons (vra1, EOL);
  237.       plvra = &CDR (*plvra);
  238.     }
  239.       return (UNBNDP (data) ? cproc (vra0, lvra) : cproc (vra0, data, lvra));
  240.     case 1:
  241.     gencase:            /* Have to loop over all dimensions. */
  242.       vra0 = scm_make_ra (1);
  243.       if ARRAYP
  244.     (ra0)
  245.       {
  246.         kmax = ARRAY_NDIM (ra0) - 1;
  247.         if (kmax < 0)
  248.           {
  249.         ARRAY_DIMS (vra0)->lbnd = 0;
  250.         ARRAY_DIMS (vra0)->ubnd = 0;
  251.         ARRAY_DIMS (vra0)->inc = 1;
  252.           }
  253.         else
  254.           {
  255.         ARRAY_DIMS (vra0)->lbnd = ARRAY_DIMS (ra0)[kmax].lbnd;
  256.         ARRAY_DIMS (vra0)->ubnd = ARRAY_DIMS (ra0)[kmax].ubnd;
  257.         ARRAY_DIMS (vra0)->inc = ARRAY_DIMS (ra0)[kmax].inc;
  258.           }
  259.         ARRAY_BASE (vra0) = ARRAY_BASE (ra0);
  260.         ARRAY_V (vra0) = ARRAY_V (ra0);
  261.       }
  262.       else
  263.     {
  264.       kmax = 0;
  265.       ARRAY_DIMS (vra0)->lbnd = 0;
  266.       ARRAY_DIMS (vra0)->ubnd = LENGTH (ra0) - 1;
  267.       ARRAY_DIMS (vra0)->inc = 1;
  268.       ARRAY_BASE (vra0) = 0;
  269.       ARRAY_V (vra0) = ra0;
  270.       ra0 = vra0;
  271.     }
  272.       lvra = EOL;
  273.       plvra = &lvra;
  274.       for (z = lra; NIMP (z); z = CDR (z))
  275.     {
  276.       ra1 = CAR (z);
  277.       vra1 = scm_make_ra (1);
  278.       ARRAY_DIMS (vra1)->lbnd = ARRAY_DIMS (vra0)->lbnd;
  279.       ARRAY_DIMS (vra1)->ubnd = ARRAY_DIMS (vra0)->ubnd;
  280.       if ARRAYP
  281.         (ra1)
  282.           {
  283.         if (kmax >= 0)
  284.           ARRAY_DIMS (vra1)->inc = ARRAY_DIMS (ra1)[kmax].inc;
  285.         ARRAY_V (vra1) = ARRAY_V (ra1);
  286.           }
  287.       else
  288.         {
  289.           ARRAY_DIMS (vra1)->inc = 1;
  290.           ARRAY_V (vra1) = ra1;
  291.         }
  292.       *plvra = scm_cons (vra1, EOL);
  293.       plvra = &CDR (*plvra);
  294.     }
  295.       inds = scm_make_uve (ARRAY_NDIM (ra0), MAKINUM (-1L));
  296.       vinds = (long *) VELTS (inds);
  297.       for (k = 0; k <= kmax; k++)
  298.     vinds[k] = ARRAY_DIMS (ra0)[k].lbnd;
  299.       k = kmax;
  300.       do
  301.     {
  302.       if (k == kmax)
  303.         {
  304.           SCM y = lra;
  305.           ARRAY_BASE (vra0) = cind (ra0, inds);
  306.           for (z = lvra; NIMP (z); z = CDR (z), y = CDR (y))
  307.         ARRAY_BASE (CAR (z)) = cind (CAR (y), inds);
  308.           if (0 == (UNBNDP (data) ? cproc (vra0, lvra) : cproc (vra0, data, lvra)))
  309.         return 0;
  310.           k--;
  311.           continue;
  312.         }
  313.       if (vinds[k] < ARRAY_DIMS (ra0)[k].ubnd)
  314.         {
  315.           vinds[k]++;
  316.           k++;
  317.           continue;
  318.         }
  319.       vinds[k] = ARRAY_DIMS (ra0)[k].lbnd - 1;
  320.       k--;
  321.     }
  322.       while (k >= 0);
  323.       return 1;
  324.     }
  325. }
  326.  
  327. static char s_array_fill[] = "array-fill!";
  328. int 
  329. scm_rafill (ra, fill, ignore)
  330.      SCM ra, fill, ignore;
  331. {
  332.   sizet i, n = ARRAY_DIMS (ra)->ubnd - ARRAY_DIMS (ra)->lbnd + 1;
  333.   long inc = ARRAY_DIMS (ra)->inc;
  334.   sizet base = ARRAY_BASE (ra);
  335.   ra = ARRAY_V (ra);
  336.   switch TYP7
  337.     (ra)
  338.       {
  339.       default:
  340.     for (i = base; n--; i += inc)
  341.       scm_aset (ra, fill, MAKINUM (i));
  342.     break;
  343.       case tc7_vector:
  344.     for (i = base; n--; i += inc)
  345.       VELTS (ra)[i] = fill;
  346.     break;
  347.       case tc7_string:
  348.     ASRTGO (ICHRP (fill), badarg2);
  349.     for (i = base; n--; i += inc)
  350.       CHARS (ra)[i] = ICHR (fill);
  351.     break;
  352.       case tc7_bvect:
  353.     {
  354.       long *ve = (long *) VELTS (ra);
  355.       if (1 == inc && (n >= LONG_BIT || n == LENGTH (ra)))
  356.         {
  357.           i = base / LONG_BIT;
  358.           if (BOOL_F == fill)
  359.         {
  360.           if (base % LONG_BIT) /* leading partial word */
  361.             ve[i++] &= ~(~0L << (base % LONG_BIT));
  362.           for (; i < (base + n) / LONG_BIT; i++)
  363.             ve[i] = 0L;
  364.           if ((base + n) % LONG_BIT) /* trailing partial word */
  365.             ve[i] &= (~0L << ((base + n) % LONG_BIT));
  366.         }
  367.           else if (BOOL_T == fill)
  368.         {
  369.           if (base % LONG_BIT)
  370.             ve[i++] |= ~0L << (base % LONG_BIT);
  371.           for (; i < (base + n) / LONG_BIT; i++)
  372.             ve[i] = ~0L;
  373.           if ((base + n) % LONG_BIT)
  374.             ve[i] |= ~(~0L << ((base + n) % LONG_BIT));
  375.         }
  376.           else
  377.           badarg2:scm_wta (fill, (char *) ARG2, s_array_fill);
  378.         }
  379.       else
  380.         {
  381.           if (BOOL_F == fill)
  382.         for (i = base; n--; i += inc)
  383.           ve[i / LONG_BIT] &= ~(1L << (i % LONG_BIT));
  384.           else if (BOOL_T == fill)
  385.         for (i = base; n--; i += inc)
  386.           ve[i / LONG_BIT] |= (1L << (i % LONG_BIT));
  387.           else
  388.         goto badarg2;
  389.         }
  390.       break;
  391.     }
  392.       case tc7_uvect:
  393.     ASRTGO (0 <= INUM (fill), badarg2);
  394.       case tc7_ivect:
  395.     ASRTGO (INUMP (fill), badarg2);
  396.     {
  397.       long f = INUM (fill), *ve = (long *) VELTS (ra);
  398.       for (i = base; n--; i += inc)
  399.         ve[i] = f;
  400.       break;
  401.     }
  402. #ifdef FLOATS
  403. #ifdef SINGLES
  404.       case tc7_fvect:
  405.     {
  406.       float f, *ve = (float *) VELTS (ra);
  407.       ASRTGO (NIMP (fill) && REALP (fill), badarg2);
  408.       f = REALPART (fill);
  409.       for (i = base; n--; i += inc)
  410.         ve[i] = f;
  411.       break;
  412.     }
  413. #endif /* SINGLES */
  414.       case tc7_dvect:
  415.     {
  416.       double f, *ve = (double *) VELTS (ra);
  417.       ASRTGO (NIMP (fill) && REALP (fill), badarg2);
  418.       f = REALPART (fill);
  419.       for (i = base; n--; i += inc)
  420.         ve[i] = f;
  421.       break;
  422.     }
  423.       case tc7_cvect:
  424.     {
  425.       double fr, fi;
  426.       double (*ve)[2] = (double (*)[2]) VELTS (ra);
  427.       ASRTGO (NIMP (fill) && INEXP (fill), badarg2);
  428.       fr = REALPART (fill);
  429.       fi = (CPLXP (fill) ? IMAG (fill) : 0.0);
  430.       for (i = base; n--; i += inc)
  431.         {
  432.           ve[i][0] = fr;
  433.           ve[i][1] = fi;
  434.         }
  435.       break;
  436.     }
  437. #endif /* FLOATS */
  438.       }
  439.   return 1;
  440. }
  441. SCM 
  442. scm_array_fill (ra, fill)
  443.      SCM ra, fill;
  444. {
  445.   scm_ramapc (scm_rafill, fill, ra, EOL, s_array_fill);
  446.   return UNSPECIFIED;
  447. }
  448.  
  449. static char s_sarray_copy[] = "serial-array-copy!";
  450. #define s_array_copy  (s_sarray_copy + 7)
  451. static int 
  452. racp (src, dst)
  453.      SCM dst, src;
  454. {
  455.   long n = (ARRAY_DIMS (src)->ubnd - ARRAY_DIMS (src)->lbnd + 1);
  456.   long inc_d, inc_s = ARRAY_DIMS (src)->inc;
  457.   sizet i_d, i_s = ARRAY_BASE (src);
  458.   dst = CAR (dst);
  459.   inc_d = ARRAY_DIMS (dst)->inc;
  460.   i_d = ARRAY_BASE (dst);
  461.   src = ARRAY_V (src);
  462.   dst = ARRAY_V (dst);
  463.   switch TYP7
  464.     (dst)
  465.       {
  466.       default:
  467.       gencase: case tc7_vector:
  468.     for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  469.       scm_aset (dst, scm_cvref (src, i_s, SCM_UNDEFINED), MAKINUM (i_d));
  470.     break;
  471.       case tc7_string:
  472.     if (tc7_string != TYP7 (dst))
  473.       goto gencase;
  474.     for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  475.       CHARS (dst)[i_d] = CHARS (src)[i_s];
  476.     break;
  477.       case tc7_bvect:
  478.     if (tc7_bvect != TYP7 (dst))
  479.       goto gencase;
  480.     if (1 == inc_d && 1 == inc_s && i_s % LONG_BIT == i_d % LONG_BIT && n >= LONG_BIT)
  481.       {
  482.         long *sv = (long *) VELTS (src);
  483.         long *dv = (long *) VELTS (dst);
  484.         sv += i_s / LONG_BIT;
  485.         dv += i_d / LONG_BIT;
  486.         if (i_s % LONG_BIT)
  487.           {            /* leading partial word */
  488.         *dv = (*dv & ~(~0L << (i_s % LONG_BIT))) | (*sv & (~0L << (i_s % LONG_BIT)));
  489.         dv++;
  490.         sv++;
  491.         n -= LONG_BIT - (i_s % LONG_BIT);
  492.           }
  493.         IVDEP (src != dst,
  494.            for (; n >= LONG_BIT; n -= LONG_BIT, sv++, dv++)
  495.            * dv = *sv;)
  496.           if (n)        /* trailing partial word */
  497.         *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
  498.       }
  499.     else
  500.       {
  501.         for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  502.           if (VELTS (src)[i_s / LONG_BIT] & (1L << (i_s % LONG_BIT)))
  503.         VELTS (dst)[i_d / LONG_BIT] |= (1L << (i_d % LONG_BIT));
  504.           else
  505.         VELTS (dst)[i_d / LONG_BIT] &= ~(1L << (i_d % LONG_BIT));
  506.       }
  507.     break;
  508.       case tc7_uvect:
  509.     if (tc7_uvect != TYP7 (src))
  510.       goto gencase;
  511.     else
  512.       {
  513.         long *d = (long *) VELTS (dst), *s = (long *) VELTS (src);
  514.         IVDEP (src != dst,
  515.            for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  516.            d[i_d] = s[i_s];)
  517.           break;
  518.       }
  519.       case tc7_ivect:
  520.     if (tc7_uvect != TYP7 (src) && tc7_ivect != TYP7 (src))
  521.       goto gencase;
  522.     else
  523.       {
  524.         long *d = (long *) VELTS (dst), *s = (long *) VELTS (src);
  525.         IVDEP (src != dst,
  526.            for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  527.            d[i_d] = s[i_s];)
  528.           break;
  529.       }
  530. #ifdef FLOATS
  531. #ifdef SINGLES
  532.       case tc7_fvect:
  533.     {
  534.       float *d = (float *) VELTS (dst);
  535.       float *s = (float *) VELTS (src);
  536.       switch TYP7
  537.         (src)
  538.           {
  539.           default:
  540.         goto gencase;
  541.           case tc7_ivect:
  542.           case tc7_uvect:
  543.         IVDEP (src != dst,
  544.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  545.                d[i_d] = ((long *) s)[i_s];)
  546.           break;
  547.           case tc7_fvect:
  548.         IVDEP (src != dst,
  549.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  550.                d[i_d] = s[i_s];)
  551.           break;
  552.           case tc7_dvect:
  553.         IVDEP (src != dst,
  554.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  555.                d[i_d] = ((double *) s)[i_s];)
  556.           break;
  557.           }
  558.       break;
  559.     }
  560. #endif /* SINGLES */
  561.       case tc7_dvect:
  562.     {
  563.       double *d = (double *) VELTS (dst);
  564.       double *s = (double *) VELTS (src);
  565.       switch TYP7
  566.         (src)
  567.           {
  568.           default:
  569.         goto gencase;
  570.           case tc7_ivect:
  571.           case tc7_uvect:
  572.         IVDEP (src != dst,
  573.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  574.                d[i_d] = ((long *) s)[i_s];)
  575.           break;
  576.           case tc7_fvect:
  577.         IVDEP (src != dst,
  578.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  579.                d[i_d] = ((float *) s)[i_s];)
  580.           break;
  581.           case tc7_dvect:
  582.         IVDEP (src != dst,
  583.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  584.                d[i_d] = s[i_s];)
  585.           break;
  586.           }
  587.       break;
  588.     }
  589.       case tc7_cvect:
  590.     {
  591.       double (*d)[2] = (double (*)[2]) VELTS (dst);
  592.       double (*s)[2] = (double (*)[2]) VELTS (src);
  593.       switch TYP7
  594.         (src)
  595.           {
  596.           default:
  597.         goto gencase;
  598.           case tc7_ivect:
  599.           case tc7_uvect:
  600.         IVDEP (src != dst,
  601.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  602.                {
  603.              d[i_d][0] = ((long *) s)[i_s];
  604.              d[i_d][1] = 0.0;
  605.                }
  606.                )
  607.           break;
  608.           case tc7_fvect:
  609.         IVDEP (src != dst,
  610.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  611.                {
  612.              d[i_d][0] = ((float *) s)[i_s];
  613.              d[i_d][1] = 0.0;
  614.                }
  615.                )
  616.           break;
  617.           case tc7_dvect:
  618.         IVDEP (src != dst,
  619.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  620.                {
  621.              d[i_d][0] = ((double *) s)[i_s];
  622.              d[i_d][1] = 0.0;
  623.                }
  624.                )
  625.           break;
  626.           case tc7_cvect:
  627.         IVDEP (src != dst,
  628.                for (; n-- > 0; i_s += inc_s, i_d += inc_d)
  629.                {
  630.              d[i_d][0] = s[i_s][0];
  631.              d[i_d][1] = s[i_s][1];
  632.                }
  633.                )
  634.           }
  635.       break;
  636.     }
  637.       }
  638. #endif /* FLOATS */
  639.   return 1;
  640. }
  641. SCM scm_array_copy (src, dst)
  642.      SCM src;
  643.      SCM dst;
  644. {
  645.   scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, EOL), s_array_copy);
  646.   return SCM_UNDEFINED;
  647. }
  648.  
  649. /* Functions callable by ARRAY-MAP! */
  650. int scm_ra_eqp (ra0, ras)
  651.      SCM ra0, ras;
  652. {
  653.   SCM ra1 = CAR (ras), ra2 = CAR (CDR (ras));
  654.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  655.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1), i2 = ARRAY_BASE (ra2);
  656.   long inc0 = ARRAY_DIMS (ra0)->inc;
  657.   long inc1 = ARRAY_DIMS (ra1)->inc;
  658.   long inc2 = ARRAY_DIMS (ra1)->inc;
  659.   ra0 = ARRAY_V (ra0);
  660.   ra1 = ARRAY_V (ra1);
  661.   ra2 = ARRAY_V (ra2);
  662.   switch (TYP7 (ra1) == TYP7 (ra2) ? TYP7 (ra1) : 0)
  663.     {
  664.     default:
  665.       {
  666.     SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
  667.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  668.       if BVE_REF
  669.         (ra0, i0)
  670.           if FALSEP
  671.         (scm_eqp (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
  672.           BVE_CLR (ra0, i0);
  673.     break;
  674.       }
  675.     case tc7_uvect:
  676.     case tc7_ivect:
  677.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  678.     if BVE_REF
  679.       (ra0, i0)
  680.         if (VELTS (ra1)[i1] != VELTS (ra2)[i2])
  681.           BVE_CLR (ra0, i0);
  682.       break;
  683. #ifdef FLOATS
  684. #ifdef SINGLES
  685.     case tc7_fvect:
  686.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  687.     if BVE_REF
  688.       (ra0, i0)
  689.         if (((float *) VELTS (ra1))[i1] != ((float *) VELTS (ra2))[i2])
  690.           BVE_CLR (ra0, i0);
  691.       break;
  692. #endif /*SINGLES*/
  693.     case tc7_dvect:
  694.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  695.     if BVE_REF
  696.       (ra0, i0)
  697.         if (((double *) VELTS (ra1))[i1] != ((double *) VELTS (ra2))[i2])
  698.           BVE_CLR (ra0, i0);
  699.       break;
  700.     case tc7_cvect:
  701.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  702.     if BVE_REF
  703.       (ra0, i0)
  704.         if (((double *) VELTS (ra1))[2 * i1] != ((double *) VELTS (ra2))[2 * i2] ||
  705.         ((double *) VELTS (ra1))[2 * i1 + 1] != ((double *) VELTS (ra2))[2 * i2 + 1])
  706.           BVE_CLR (ra0, i0);
  707.       break;
  708. #endif /*FLOATS*/
  709.     }
  710.   return 1;
  711. }
  712. /* opt 0 means <, nonzero means >= */
  713. static int ra_compare (ra0, ra1, ra2, opt)
  714.      SCM ra0, ra1, ra2;
  715.      int opt;
  716. {
  717.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  718.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1), i2 = ARRAY_BASE (ra2);
  719.   long inc0 = ARRAY_DIMS (ra0)->inc;
  720.   long inc1 = ARRAY_DIMS (ra1)->inc;
  721.   long inc2 = ARRAY_DIMS (ra1)->inc;
  722.   ra0 = ARRAY_V (ra0);
  723.   ra1 = ARRAY_V (ra1);
  724.   ra2 = ARRAY_V (ra2);
  725.   switch (TYP7 (ra1) == TYP7 (ra2) ? TYP7 (ra1) : 0)
  726.     {
  727.     default:
  728.       {
  729.     SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
  730.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  731.       if BVE_REF
  732.         (ra0, i0)
  733.           if (opt ?
  734.           NFALSEP (scm_lessp (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
  735.           FALSEP (scm_lessp (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
  736.         BVE_CLR (ra0, i0);
  737.     break;
  738.       }
  739.     case tc7_uvect:
  740.     case tc7_ivect:
  741.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  742.     {
  743.       if BVE_REF
  744.         (ra0, i0)
  745.           if (opt ?
  746.           VELTS (ra1)[i1] < VELTS (ra2)[i2] :
  747.           VELTS (ra1)[i1] >= VELTS (ra2)[i2])
  748.         BVE_CLR (ra0, i0);
  749.     }
  750.       break;
  751. #ifdef FLOATS
  752. #ifdef SINGLES
  753.     case tc7_fvect:
  754.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  755.     if BVE_REF
  756.       (ra0, i0)
  757.         if (opt ?
  758.         ((float *) VELTS (ra1))[i1] < ((float *) VELTS (ra2))[i2] :
  759.         ((float *) VELTS (ra1))[i1] >= ((float *) VELTS (ra2))[i2])
  760.           BVE_CLR (ra0, i0);
  761.       break;
  762. #endif /*SINGLES*/
  763.     case tc7_dvect:
  764.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  765.     if BVE_REF
  766.       (ra0, i0)
  767.         if (opt ?
  768.         ((double *) VELTS (ra1))[i1] < ((double *) VELTS (ra2))[i2] :
  769.         ((double *) VELTS (ra1))[i1] >= ((double *) VELTS (ra2))[i2])
  770.           BVE_CLR (ra0, i0);
  771.       break;
  772. #endif /*FLOATS*/
  773.     }
  774.   return 1;
  775. }
  776. int scm_ra_lessp (ra0, ras)
  777.      SCM ra0, ras;
  778. {
  779.   return ra_compare (ra0, CAR (ras), CAR (CDR (ras)), 0);
  780. }
  781. int scm_ra_leqp (ra0, ras)
  782.      SCM ra0, ras;
  783. {
  784.   return ra_compare (ra0, CAR (CDR (ras)), CAR (ras), 1);
  785. }
  786. int scm_ra_grp (ra0, ras)
  787.      SCM ra0, ras;
  788. {
  789.   return ra_compare (ra0, CAR (CDR (ras)), CAR (ras), 0);
  790. }
  791. int scm_ra_greqp (ra0, ras)
  792.      SCM ra0, ras;
  793. {
  794.   return ra_compare (ra0, CAR (ras), CAR (CDR (ras)), 1);
  795. }
  796.  
  797. int scm_ra_sum (ra0, ras)
  798.      SCM ra0, ras;
  799. {
  800.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  801.   sizet i0 = ARRAY_BASE (ra0);
  802.   long inc0 = ARRAY_DIMS (ra0)->inc;
  803.   ra0 = ARRAY_V (ra0);
  804.   if NNULLP
  805.     (ras)
  806.       {
  807.     SCM ra1 = CAR (ras);
  808.     sizet i1 = ARRAY_BASE (ra1);
  809.     long inc1 = ARRAY_DIMS (ra1)->inc;
  810.     ra1 = ARRAY_V (ra1);
  811.     switch (TYP7 (ra0) == TYP7 (ra1) ? TYP7 (ra0) : 0)
  812.       {
  813.       default:
  814.         {
  815.           SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  816.           for (; n-- > 0; i0 += inc0, i1 += inc1)
  817.         scm_aset (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
  818.               MAKINUM (i0));
  819.           break;
  820.         }
  821.       case tc7_uvect:
  822.       case tc7_ivect:
  823.         {
  824.           long *v0 = VELTS (ra0);
  825.           long *v1 = VELTS (ra1);
  826.           IVDEP (ra0 != ra1,
  827.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  828.              v0[i0] += v1[i1]);
  829.           break;
  830.         }
  831. #ifdef FLOATS
  832. #ifdef SINGLES
  833.       case tc7_fvect:
  834.         {
  835.           float *v0 = (float *) VELTS (ra0);
  836.           float *v1 = (float *) VELTS (ra1);
  837.           IVDEP (ra0 != ra1,
  838.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  839.              v0[i0] += v1[i1]);
  840.           break;
  841.         }
  842. #endif /* SINGLES */
  843.       case tc7_dvect:
  844.         {
  845.           double *v0 = (double *) VELTS (ra0);
  846.           double *v1 = (double *) VELTS (ra1);
  847.           IVDEP (ra0 != ra1,
  848.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  849.              v0[i0] += v1[i1]);
  850.           break;
  851.         }
  852.       case tc7_cvect:
  853.         {
  854.           double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  855.           double (*v1)[2] = (double (*)[2]) VELTS (ra1);
  856.           IVDEP (ra0 != ra1,
  857.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  858.              {
  859.                v0[i0][0] += v1[i1][0];
  860.                v0[i0][1] += v1[i1][1];
  861.              }
  862.              );
  863.           break;
  864.         }
  865. #endif /* FLOATS */
  866.       }
  867.       }
  868.   return 1;
  869. }
  870.  
  871. int scm_ra_difference (ra0, ras)
  872.      SCM ra0, ras;
  873. {
  874.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  875.   sizet i0 = ARRAY_BASE (ra0);
  876.   long inc0 = ARRAY_DIMS (ra0)->inc;
  877.   ra0 = ARRAY_V (ra0);
  878.   if NULLP
  879.     (ras)
  880.       {
  881.     switch TYP7
  882.       (ra0)
  883.         {
  884.         default:
  885.           {
  886.         SCM e0 = SCM_UNDEFINED;
  887.         for (; n-- > 0; i0 += inc0)
  888.           scm_aset (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), MAKINUM (i0));
  889.         break;
  890.           }
  891. #ifdef FLOATS
  892. #ifdef SINGLES
  893.         case tc7_fvect:
  894.           {
  895.         float *v0 = (float *) VELTS (ra0);
  896.         for (; n-- > 0; i0 += inc0)
  897.           v0[i0] = -v0[i0];
  898.         break;
  899.           }
  900. #endif /* SINGLES */
  901.         case tc7_dvect:
  902.           {
  903.         double *v0 = (double *) VELTS (ra0);
  904.         for (; n-- > 0; i0 += inc0)
  905.           v0[i0] = -v0[i0];
  906.         break;
  907.           }
  908.         case tc7_cvect:
  909.           {
  910.         double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  911.         for (; n-- > 0; i0 += inc0)
  912.           {
  913.             v0[i0][0] = -v0[i0][0];
  914.             v0[i0][1] = -v0[i0][1];
  915.           }
  916.         break;
  917.           }
  918. #endif /* FLOATS */
  919.         }
  920.       }
  921.   else
  922.     {
  923.       SCM ra1 = CAR (ras);
  924.       sizet i1 = ARRAY_BASE (ra1);
  925.       long inc1 = ARRAY_DIMS (ra1)->inc;
  926.       ra1 = ARRAY_V (ra1);
  927.       switch (TYP7 (ra0) == TYP7 (ra1) ? TYP7 (ra0) : 0)
  928.     {
  929.     default:
  930.       {
  931.         SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  932.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  933.           scm_aset (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), MAKINUM (i0));
  934.         break;
  935.       }
  936. #ifdef FLOATS
  937. #ifdef SINGLES
  938.     case tc7_fvect:
  939.       {
  940.         float *v0 = (float *) VELTS (ra0);
  941.         float *v1 = (float *) VELTS (ra1);
  942.         IVDEP (ra0 != ra1,
  943.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  944.            v0[i0] -= v1[i1]);
  945.         break;
  946.       }
  947. #endif /* SINGLES */
  948.     case tc7_dvect:
  949.       {
  950.         double *v0 = (double *) VELTS (ra0);
  951.         double *v1 = (double *) VELTS (ra1);
  952.         IVDEP (ra0 != ra1,
  953.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  954.            v0[i0] -= v1[i1]);
  955.         break;
  956.       }
  957.     case tc7_cvect:
  958.       {
  959.         double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  960.         double (*v1)[2] = (double (*)[2]) VELTS (ra1);
  961.         IVDEP (ra0 != ra1,
  962.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  963.            {
  964.              v0[i0][0] -= v1[i1][0];
  965.              v0[i0][1] -= v1[i1][1];
  966.            }
  967.            )
  968.           break;
  969.       }
  970. #endif /* FLOATS */
  971.     }
  972.     }
  973.   return 1;
  974. }
  975.  
  976. int scm_ra_product (ra0, ras)
  977.      SCM ra0, ras;
  978. {
  979.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  980.   sizet i0 = ARRAY_BASE (ra0);
  981.   long inc0 = ARRAY_DIMS (ra0)->inc;
  982.   ra0 = ARRAY_V (ra0);
  983.   if NNULLP
  984.     (ras)
  985.       {
  986.     SCM ra1 = CAR (ras);
  987.     sizet i1 = ARRAY_BASE (ra1);
  988.     long inc1 = ARRAY_DIMS (ra1)->inc;
  989.     ra1 = ARRAY_V (ra1);
  990.     switch (TYP7 (ra0) == TYP7 (ra1) ? TYP7 (ra0) : 0)
  991.       {
  992.       default:
  993.         {
  994.           SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  995.           for (; n-- > 0; i0 += inc0, i1 += inc1)
  996.         scm_aset (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
  997.               MAKINUM (i0));
  998.           break;
  999.         }
  1000.       case tc7_uvect:
  1001.       case tc7_ivect:
  1002.         {
  1003.           long *v0 = VELTS (ra0);
  1004.           long *v1 = VELTS (ra1);
  1005.           IVDEP (ra0 != ra1,
  1006.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  1007.              v0[i0] *= v1[i1]);
  1008.           break;
  1009.         }
  1010. #ifdef FLOATS
  1011. #ifdef SINGLES
  1012.       case tc7_fvect:
  1013.         {
  1014.           float *v0 = (float *) VELTS (ra0);
  1015.           float *v1 = (float *) VELTS (ra1);
  1016.           IVDEP (ra0 != ra1,
  1017.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  1018.              v0[i0] *= v1[i1]);
  1019.           break;
  1020.         }
  1021. #endif /* SINGLES */
  1022.       case tc7_dvect:
  1023.         {
  1024.           double *v0 = (double *) VELTS (ra0);
  1025.           double *v1 = (double *) VELTS (ra1);
  1026.           IVDEP (ra0 != ra1,
  1027.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  1028.              v0[i0] *= v1[i1]);
  1029.           break;
  1030.         }
  1031.       case tc7_cvect:
  1032.         {
  1033.           double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  1034.           register double r;
  1035.           double (*v1)[2] = (double (*)[2]) VELTS (ra1);
  1036.           IVDEP (ra0 != ra1,
  1037.              for (; n-- > 0; i0 += inc0, i1 += inc1)
  1038.              {
  1039.                r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
  1040.                v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
  1041.                v0[i0][0] = r;
  1042.              }
  1043.              );
  1044.           break;
  1045.         }
  1046. #endif /* FLOATS */
  1047.       }
  1048.       }
  1049.   return 1;
  1050. }
  1051. int scm_ra_divide (ra0, ras)
  1052.      SCM ra0, ras;
  1053. {
  1054.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1055.   sizet i0 = ARRAY_BASE (ra0);
  1056.   long inc0 = ARRAY_DIMS (ra0)->inc;
  1057.   ra0 = ARRAY_V (ra0);
  1058.   if NULLP
  1059.     (ras)
  1060.       {
  1061.     switch TYP7
  1062.       (ra0)
  1063.         {
  1064.         default:
  1065.           {
  1066.         SCM e0 = SCM_UNDEFINED;
  1067.         for (; n-- > 0; i0 += inc0)
  1068.           scm_aset (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), MAKINUM (i0));
  1069.         break;
  1070.           }
  1071. #ifdef FLOATS
  1072. #ifdef SINGLES
  1073.         case tc7_fvect:
  1074.           {
  1075.         float *v0 = (float *) VELTS (ra0);
  1076.         for (; n-- > 0; i0 += inc0)
  1077.           v0[i0] = 1.0 / v0[i0];
  1078.         break;
  1079.           }
  1080. #endif /* SINGLES */
  1081.         case tc7_dvect:
  1082.           {
  1083.         double *v0 = (double *) VELTS (ra0);
  1084.         for (; n-- > 0; i0 += inc0)
  1085.           v0[i0] = 1.0 / v0[i0];
  1086.         break;
  1087.           }
  1088.         case tc7_cvect:
  1089.           {
  1090.         register double d;
  1091.         double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  1092.         for (; n-- > 0; i0 += inc0)
  1093.           {
  1094.             d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
  1095.             v0[i0][0] /= d;
  1096.             v0[i0][1] /= -d;
  1097.           }
  1098.         break;
  1099.           }
  1100. #endif /* FLOATS */
  1101.         }
  1102.       }
  1103.   else
  1104.     {
  1105.       SCM ra1 = CAR (ras);
  1106.       sizet i1 = ARRAY_BASE (ra1);
  1107.       long inc1 = ARRAY_DIMS (ra1)->inc;
  1108.       ra1 = ARRAY_V (ra1);
  1109.       switch (TYP7 (ra0) == TYP7 (ra1) ? TYP7 (ra0) : 0)
  1110.     {
  1111.     default:
  1112.       {
  1113.         SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  1114.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  1115.           scm_aset (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), MAKINUM (i0));
  1116.         break;
  1117.       }
  1118. #ifdef FLOATS
  1119. #ifdef SINGLES
  1120.     case tc7_fvect:
  1121.       {
  1122.         float *v0 = (float *) VELTS (ra0);
  1123.         float *v1 = (float *) VELTS (ra1);
  1124.         IVDEP (ra0 != ra1,
  1125.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  1126.            v0[i0] /= v1[i1]);
  1127.         break;
  1128.       }
  1129. #endif /* SINGLES */
  1130.     case tc7_dvect:
  1131.       {
  1132.         double *v0 = (double *) VELTS (ra0);
  1133.         double *v1 = (double *) VELTS (ra1);
  1134.         IVDEP (ra0 != ra1,
  1135.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  1136.            v0[i0] /= v1[i1]);
  1137.         break;
  1138.       }
  1139.     case tc7_cvect:
  1140.       {
  1141.         register double d, r;
  1142.         double (*v0)[2] = (double (*)[2]) VELTS (ra0);
  1143.         double (*v1)[2] = (double (*)[2]) VELTS (ra1);
  1144.         IVDEP (ra0 != ra1,
  1145.            for (; n-- > 0; i0 += inc0, i1 += inc1)
  1146.            {
  1147.              d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
  1148.              r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
  1149.              v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
  1150.              v0[i0][0] = r;
  1151.            }
  1152.            )
  1153.           break;
  1154.       }
  1155. #endif /* FLOATS */
  1156.     }
  1157.     }
  1158.   return 1;
  1159. }
  1160. static int ra_identity (dst, src)
  1161.      SCM src, dst;
  1162. {
  1163.   return racp (CAR (src), scm_cons (dst, EOL));
  1164. }
  1165.  
  1166. static int ramap (ra0, proc, ras)
  1167.      SCM ra0, proc, ras;
  1168. {
  1169.   long i = ARRAY_DIMS (ra0)->lbnd;
  1170.   long inc = ARRAY_DIMS (ra0)->inc;
  1171.   long n = ARRAY_DIMS (ra0)->ubnd;
  1172.   long base = ARRAY_BASE (ra0) - i * inc;
  1173.   ra0 = ARRAY_V (ra0);
  1174.   if NULLP
  1175.     (ras)
  1176.       for (; i <= n; i++)
  1177.     scm_aset (ra0, scm_apply (proc, EOL, EOL), MAKINUM (i * inc + base));
  1178.   else
  1179.     {
  1180.       SCM ra1 = CAR (ras);
  1181.       SCM args, *ve = &ras;
  1182.       sizet k, i1 = ARRAY_BASE (ra1);
  1183.       long inc1 = ARRAY_DIMS (ra1)->inc;
  1184.       ra1 = ARRAY_V (ra1);
  1185.       ras = CDR (ras);
  1186.       if NULLP
  1187.     (ras)
  1188.       ras = nullvect;
  1189.       else
  1190.     {
  1191.       ras = scm_vector (ras);
  1192.       ve = VELTS (ras);
  1193.     }
  1194.       for (; i <= n; i++, i1 += inc1)
  1195.     {
  1196.       args = EOL;
  1197.       for (k = LENGTH (ras); k--;)
  1198.         args = scm_cons (scm_aref (ve[k], MAKINUM (i)), args);
  1199.       args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
  1200.       scm_aset (ra0, scm_apply (proc, args, EOL), MAKINUM (i * inc + base));
  1201.     }
  1202.     }
  1203.   return 1;
  1204. }
  1205. static int ramap_cxr (ra0, proc, ras)
  1206.      SCM ra0, proc, ras;
  1207. {
  1208.   SCM ra1 = CAR (ras);
  1209.   SCM e1 = SCM_UNDEFINED;
  1210.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1);
  1211.   long inc0 = ARRAY_DIMS (ra0)->inc, inc1 = ARRAY_DIMS (ra1)->inc;
  1212.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra1)->lbnd + 1;
  1213.   ra0 = ARRAY_V (ra0);
  1214.   ra1 = ARRAY_V (ra1);
  1215.   switch TYP7
  1216.     (ra0)
  1217.       {
  1218.       default:
  1219.       gencase:
  1220.     for (; n-- > 0; i0 += inc0, i1 += inc1)
  1221.       scm_aset (ra0, scm_apply (proc, RVREF (ra1, i1, e1), listofnull), MAKINUM (i0));
  1222.     break;
  1223. #ifdef FLOATS
  1224. #ifdef SINGLES
  1225.       case tc7_fvect:
  1226.     {
  1227.       float *dst = (float *) VELTS (ra0);
  1228.       switch TYP7
  1229.         (ra1)
  1230.           {
  1231.           default:
  1232.         goto gencase;
  1233.           case tc7_fvect:
  1234.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  1235.           dst[i0] = DSUBRF (proc) ((double) ((float *) VELTS (ra1))[i1]);
  1236.         break;
  1237.           case tc7_uvect:
  1238.           case tc7_ivect:
  1239.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  1240.           dst[i0] = DSUBRF (proc) ((double) VELTS (ra1)[i1]);
  1241.         break;
  1242.           }
  1243.       break;
  1244.     }
  1245. #endif /* SINGLES */
  1246.       case tc7_dvect:
  1247.     {
  1248.       double *dst = (double *) VELTS (ra0);
  1249.       switch TYP7
  1250.         (ra1)
  1251.           {
  1252.           default:
  1253.         goto gencase;
  1254.           case tc7_dvect:
  1255.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  1256.           dst[i0] = DSUBRF (proc) (((double *) VELTS (ra1))[i1]);
  1257.         break;
  1258.           case tc7_uvect:
  1259.           case tc7_ivect:
  1260.         for (; n-- > 0; i0 += inc0, i1 += inc1)
  1261.           dst[i0] = DSUBRF (proc) ((double) VELTS (ra1)[i1]);
  1262.         break;
  1263.           }
  1264.       break;
  1265.     }
  1266. #endif /* FLOATS */
  1267.       }
  1268.   return 1;
  1269. }
  1270. static int ramap_rp (ra0, proc, ras)
  1271.      SCM ra0, proc, ras;
  1272. {
  1273.   SCM ra1 = CAR (ras), ra2 = CAR (CDR (ras));
  1274.   SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
  1275.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1276.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1), i2 = ARRAY_BASE (ra2);
  1277.   long inc0 = ARRAY_DIMS (ra0)->inc;
  1278.   long inc1 = ARRAY_DIMS (ra1)->inc;
  1279.   long inc2 = ARRAY_DIMS (ra1)->inc;
  1280.   ra0 = ARRAY_V (ra0);
  1281.   ra1 = ARRAY_V (ra1);
  1282.   ra2 = ARRAY_V (ra2);
  1283.   switch (TYP7 (ra1) == TYP7 (ra2) ? TYP7 (ra1) : 0)
  1284.     {
  1285.     default:
  1286.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1287.     if BVE_REF
  1288.       (ra0, i0)
  1289.         if FALSEP
  1290.           (SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
  1291.         BVE_CLR (ra0, i0);
  1292.       break;
  1293.     case tc7_uvect:
  1294.     case tc7_ivect:
  1295.       for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1296.     if BVE_REF
  1297.       (ra0, i0)
  1298.         {
  1299.           if FALSEP
  1300.         (SUBRF (proc) (MAKINUM (VELTS (ra1)[i1]),
  1301.                    MAKINUM (VELTS (ra2)[i2])))
  1302.           BVE_CLR (ra0, i0);
  1303.         }
  1304.       break;
  1305. #ifdef FLOATS
  1306. #ifdef SINGLES
  1307.     case tc7_fvect:
  1308.       {
  1309.     SCM a1 = makflo (1.0), a2 = makflo (1.0);
  1310.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1311.       if BVE_REF
  1312.         (ra0, i0)
  1313.           {
  1314.         FLO (a1) = ((float *) VELTS (ra1))[i1];
  1315.         FLO (a2) = ((float *) VELTS (ra2))[i2];
  1316.         if FALSEP
  1317.           (SUBRF (proc) (a1, a2))
  1318.             BVE_CLR (ra0, i0);
  1319.           }
  1320.     break;
  1321.       }
  1322. #endif /*SINGLES*/
  1323.     case tc7_dvect:
  1324.       {
  1325.     SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
  1326.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1327.       if BVE_REF
  1328.         (ra0, i0)
  1329.           {
  1330.         REAL (a1) = ((double *) VELTS (ra1))[i1];
  1331.         REAL (a2) = ((double *) VELTS (ra2))[i2];
  1332.         if FALSEP
  1333.           (SUBRF (proc) (a1, a2))
  1334.             BVE_CLR (ra0, i0);
  1335.           }
  1336.     break;
  1337.       }
  1338.     case tc7_cvect:
  1339.       {
  1340.     SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
  1341.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1342.       if BVE_REF
  1343.         (ra0, i0)
  1344.           {
  1345.         REAL (a1) = ((double *) VELTS (ra1))[2 * i1];
  1346.         IMAG (a1) = ((double *) VELTS (ra1))[2 * i1 + 1];
  1347.         REAL (a2) = ((double *) VELTS (ra2))[2 * i2];
  1348.         IMAG (a2) = ((double *) VELTS (ra2))[2 * i2 + 1];
  1349.         if FALSEP
  1350.           (SUBRF (proc) (a1, a2))
  1351.             BVE_CLR (ra0, i0);
  1352.           }
  1353.     break;
  1354.       }
  1355. #endif /*FLOATS*/
  1356.     }
  1357.   return 1;
  1358. }
  1359. static int ramap_1 (ra0, proc, ras)
  1360.      SCM ra0, proc, ras;
  1361. {
  1362.   SCM ra1 = CAR (ras);
  1363.   SCM e1 = SCM_UNDEFINED;
  1364.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1365.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1);
  1366.   long inc0 = ARRAY_DIMS (ra0)->inc, inc1 = ARRAY_DIMS (ra1)->inc;
  1367.   ra0 = ARRAY_V (ra0);
  1368.   ra1 = ARRAY_V (ra1);
  1369.   if (tc7_vector == TYP7 (ra0))
  1370.     for (; n-- > 0; i0 += inc0, i1 += inc1)
  1371.       scm_aset (ra0, SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), MAKINUM (i0));
  1372.   else
  1373.     for (; n-- > 0; i0 += inc0, i1 += inc1)
  1374.       scm_aset (ra0, SUBRF (proc) (RVREF (ra1, i1, e1)), MAKINUM (i0));
  1375.   return 1;
  1376. }
  1377. static int ramap_2o (ra0, proc, ras)
  1378.      SCM ra0, proc, ras;
  1379. {
  1380.   SCM ra1 = CAR (ras);
  1381.   SCM e1 = SCM_UNDEFINED;
  1382.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1383.   sizet i0 = ARRAY_BASE (ra0), i1 = ARRAY_BASE (ra1);
  1384.   long inc0 = ARRAY_DIMS (ra0)->inc, inc1 = ARRAY_DIMS (ra1)->inc;
  1385.   ra0 = ARRAY_V (ra0);
  1386.   ra1 = ARRAY_V (ra1);
  1387.   ras = CDR (ras);
  1388.   if NULLP
  1389.     (ras)
  1390.       {
  1391.     if (tc7_vector == TYP7 (ra0))
  1392.       for (; n-- > 0; i0 += inc0, i1 += inc1)
  1393.         scm_aset (ra0, SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
  1394.           MAKINUM (i0));
  1395.     else
  1396.       for (; n-- > 0; i0 += inc0, i1 += inc1)
  1397.         scm_aset (ra0, SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
  1398.           MAKINUM (i0));
  1399.       }
  1400.   else
  1401.     {
  1402.       SCM ra2 = CAR (ras);
  1403.       SCM e2 = SCM_UNDEFINED;
  1404.       sizet i2 = ARRAY_BASE (ra2);
  1405.       long inc2 = ARRAY_DIMS (ra2)->inc;
  1406.       ra2 = ARRAY_V (ra2);
  1407.       if (tc7_vector == TYP7 (ra0))
  1408.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1409.       scm_aset (ra0,
  1410.         SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
  1411.         MAKINUM (i0));
  1412.       else
  1413.     for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
  1414.       scm_aset (ra0,
  1415.         SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
  1416.         MAKINUM (i0));
  1417.     }
  1418.   return 1;
  1419. }
  1420. static int ramap_a (ra0, proc, ras)
  1421.      SCM ra0, proc, ras;
  1422. {
  1423.   SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  1424.   long n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1425.   sizet i0 = ARRAY_BASE (ra0);
  1426.   long inc0 = ARRAY_DIMS (ra0)->inc;
  1427.   ra0 = ARRAY_V (ra0);
  1428.   if NULLP
  1429.     (ras)
  1430.       for (; n-- > 0; i0 += inc0)
  1431.     scm_aset (ra0, SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), MAKINUM (i0));
  1432.   else
  1433.     {
  1434.       SCM ra1 = CAR (ras);
  1435.       sizet i1 = ARRAY_BASE (ra1);
  1436.       long inc1 = ARRAY_DIMS (ra1)->inc;
  1437.       ra1 = ARRAY_V (ra1);
  1438.       for (; n-- > 0; i0 += inc0, i1 += inc1)
  1439.     scm_aset (ra0, SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
  1440.           MAKINUM (i0));
  1441.     }
  1442.   return 1;
  1443. }
  1444.  
  1445. /* These tables are a kluge that will not scale well when more
  1446.    vectorized subrs are added.  It is tempting to steal some bits from
  1447.    the CAR of all subrs (like those selected by SMOBNUM) to hold an
  1448.    offset into a table of vectorized subrs.  */
  1449.  
  1450. static ra_iproc ra_rpsubrs[] =
  1451. {
  1452.   {"=", SCM_UNDEFINED, scm_ra_eqp},
  1453.   {"<", SCM_UNDEFINED, scm_ra_lessp},
  1454.   {"<=", SCM_UNDEFINED, scm_ra_leqp},
  1455.   {">", SCM_UNDEFINED, scm_ra_grp},
  1456.   {">=", SCM_UNDEFINED, scm_ra_greqp},
  1457.   {0, 0, 0}};
  1458. static ra_iproc ra_asubrs[] =
  1459. {
  1460.   {"+", SCM_UNDEFINED, scm_ra_sum},
  1461.   {"-", SCM_UNDEFINED, scm_ra_difference},
  1462.   {"*", SCM_UNDEFINED, scm_ra_product},
  1463.   {"/", SCM_UNDEFINED, scm_ra_divide},
  1464.   {0, 0, 0}};
  1465.  
  1466. static char s_sarray_map[] = "serial-array-map!";
  1467. #define s_array_map  (s_sarray_map + 7)
  1468. SCM scm_array_map (ra0, proc, lra)
  1469.      SCM ra0, proc, lra;
  1470. {
  1471.   ASSERT (BOOL_T == scm_procedurep (proc), proc, ARG2, s_array_map);
  1472.   switch TYP7
  1473.     (proc)
  1474.       {
  1475.       default:
  1476.       gencase:
  1477.     scm_ramapc (ramap, proc, ra0, lra, s_array_map);
  1478.     return UNSPECIFIED;
  1479.       case tc7_subr_1:
  1480.     scm_ramapc (ramap_1, proc, ra0, lra, s_array_map);
  1481.     return UNSPECIFIED;
  1482.       case tc7_subr_2:
  1483.       case tc7_subr_2o:
  1484.     scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
  1485.     return UNSPECIFIED;
  1486.       case tc7_cxr:
  1487.     if (!SUBRF (proc))
  1488.       goto gencase;
  1489.     scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map);
  1490.     return UNSPECIFIED;
  1491.       case tc7_rpsubr:
  1492.     {
  1493.       ra_iproc *p;
  1494.       if (FALSEP (scm_arrayp (ra0, BOOL_T)))
  1495.         goto gencase;
  1496.       scm_array_fill (ra0, BOOL_T);
  1497.       for (p = ra_rpsubrs; p->name; p++)
  1498.         if (proc == p->sproc)
  1499.           {
  1500.         while (NNULLP (lra) && NNULLP (CDR (lra)))
  1501.           {
  1502.             scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
  1503.             lra = CDR (lra);
  1504.           }
  1505.         return UNSPECIFIED;
  1506.           }
  1507.       while (NNULLP (lra) && NNULLP (CDR (lra)))
  1508.         {
  1509.           scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map);
  1510.           lra = CDR (lra);
  1511.         }
  1512.       return UNSPECIFIED;
  1513.     }
  1514.       case tc7_asubr:
  1515.     if NULLP
  1516.       (lra)
  1517.         {
  1518.           SCM prot, fill = SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
  1519.           if INUMP
  1520.         (fill)
  1521.           {
  1522.             prot = scm_array_prot (ra0);
  1523.             if (NIMP (prot) && INEXP (prot))
  1524.               fill = scm_makdbl ((double) INUM (fill), 0.0);
  1525.           }
  1526.           scm_array_fill (ra0, fill);
  1527.         }
  1528.     else
  1529.       {
  1530.         SCM tail, ra1 = CAR (lra);
  1531.         SCM v0 = (NIMP (ra0) && ARRAYP (ra0) ? ARRAY_V (ra0) : ra0);
  1532.         ra_iproc *p;
  1533.         /* Check to see if order might matter.
  1534.            This might be an argument for a separate
  1535.            SERIAL-ARRAY-MAP! */
  1536.         if (v0 == ra1 || (NIMP (ra1) && ARRAYP (ra1) && v0 == ARRAY_V (ra1)))
  1537.           if (ra0 != ra1 || (ARRAYP(ra0) && !ARRAY_CONTP(ra0)))
  1538.         goto gencase;
  1539.         for (tail = CDR (lra); NNULLP (tail); tail = CDR (tail))
  1540.           {
  1541.         ra1 = CAR (tail);
  1542.         if (v0 == ra1 || (NIMP (ra1) && ARRAYP (ra1) && v0 == ARRAY_V (ra1)))
  1543.           goto gencase;
  1544.           }
  1545.         for (p = ra_asubrs; p->name; p++)
  1546.           if (proc == p->sproc)
  1547.         {
  1548.           if (ra0 != CAR (lra))
  1549.             scm_ramapc (ra_identity, SCM_UNDEFINED, ra0, scm_cons (CAR (lra), EOL), s_array_map);
  1550.           lra = CDR (lra);
  1551.           while (1)
  1552.             {
  1553.               scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
  1554.               if (IMP (lra) || IMP (CDR (lra)))
  1555.             return UNSPECIFIED;
  1556.               lra = CDR (lra);
  1557.             }
  1558.         }
  1559.         scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
  1560.         lra = CDR (lra);
  1561.         if NIMP
  1562.           (lra)
  1563.         for (lra = CDR (lra); NIMP (lra); lra = CDR (lra))
  1564.           scm_ramapc (ramap_a, proc, ra0, lra, s_array_map);
  1565.       }
  1566.     return UNSPECIFIED;
  1567.       }
  1568. }
  1569.  
  1570. static int rafe (ra0, proc, ras)
  1571.      SCM ra0, proc, ras;
  1572. {
  1573.   long i = ARRAY_DIMS (ra0)->lbnd;
  1574.   sizet i0 = ARRAY_BASE (ra0);
  1575.   long inc0 = ARRAY_DIMS (ra0)->inc;
  1576.   long n = ARRAY_DIMS (ra0)->ubnd;
  1577.   ra0 = ARRAY_V (ra0);
  1578.   if NULLP
  1579.     (ras)
  1580.       for (; i <= n; i++, i0 += inc0)
  1581.     scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), listofnull);
  1582.   else
  1583.     {
  1584.       SCM ra1 = CAR (ras);
  1585.       SCM args, *ve = &ras;
  1586.       sizet k, i1 = ARRAY_BASE (ra1);
  1587.       long inc1 = ARRAY_DIMS (ra1)->inc;
  1588.       ra1 = ARRAY_V (ra1);
  1589.       ras = CDR (ras);
  1590.       if NULLP
  1591.     (ras)
  1592.       ras = nullvect;
  1593.       else
  1594.     {
  1595.       ras = scm_vector (ras);
  1596.       ve = VELTS (ras);
  1597.     }
  1598.       for (; i <= n; i++, i0 += inc0, i1 += inc1)
  1599.     {
  1600.       args = EOL;
  1601.       for (k = LENGTH (ras); k--;)
  1602.         args = scm_cons (scm_aref (ve[k], MAKINUM (i)), args);
  1603.       args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
  1604.       scm_apply (proc, args, EOL);
  1605.     }
  1606.     }
  1607.   return 1;
  1608. }
  1609. static char s_array_for_each[] = "array-for-each";
  1610. SCM scm_array_for_each (proc, ra0, lra)
  1611.      SCM proc, ra0, lra;
  1612. {
  1613.   ASSERT (BOOL_T == scm_procedurep (proc), proc, ARG1, s_array_for_each);
  1614.   scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
  1615.   return UNSPECIFIED;
  1616. }
  1617.  
  1618. static char s_array_imap[] = "array-index-map!";
  1619. SCM scm_array_imap (ra, proc)
  1620.      SCM ra, proc;
  1621. {
  1622.   sizet i;
  1623.   ASSERT (NIMP (ra), ra, ARG1, s_array_imap);
  1624.   ASSERT (BOOL_T == scm_procedurep (proc), proc, ARG2, s_array_imap);
  1625.   switch TYP7
  1626.     (ra)
  1627.       {
  1628.       default:
  1629.       badarg:scm_wta (ra, (char *) ARG1, s_array_imap);
  1630.       case tc7_vector:
  1631.     {
  1632.       SCM *ve = VELTS (ra);
  1633.       for (i = 0; i < LENGTH (ra); i++)
  1634.         ve[i] = scm_apply (proc, MAKINUM (i), listofnull);
  1635.       return UNSPECIFIED;
  1636.     }
  1637.       case tc7_string:
  1638.       case tc7_bvect:
  1639.       case tc7_uvect:
  1640.       case tc7_ivect:
  1641.       case tc7_fvect:
  1642.       case tc7_dvect:
  1643.       case tc7_cvect:
  1644.     for (i = 0; i < LENGTH (ra); i++)
  1645.       scm_aset (ra, scm_apply (proc, MAKINUM (i), listofnull), MAKINUM (i));
  1646.     return UNSPECIFIED;
  1647.       case tc7_smob:
  1648.     ASRTGO (ARRAYP (ra), badarg);
  1649.     {
  1650.       SCM args = EOL;
  1651.       SCM inds = scm_make_uve (ARRAY_NDIM (ra), MAKINUM (-1L));
  1652.       long *vinds = VELTS (inds);
  1653.       int j, k, kmax = ARRAY_NDIM (ra) - 1;
  1654.       for (k = 0; k <= kmax; k++)
  1655.         vinds[k] = ARRAY_DIMS (ra)[k].lbnd;
  1656.       k = kmax;
  1657.       do
  1658.         {
  1659.           if (k == kmax)
  1660.         {
  1661.           vinds[k] = ARRAY_DIMS (ra)[k].lbnd;
  1662.           i = cind (ra, inds);
  1663.           for (; vinds[k] <= ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
  1664.             {
  1665.               for (j = kmax + 1, args = EOL; j--;)
  1666.             args = scm_cons (MAKINUM (vinds[j]), args);
  1667.               scm_aset (ARRAY_V (ra), scm_apply (proc, args, EOL), MAKINUM (i));
  1668.               i += ARRAY_DIMS (ra)[k].inc;
  1669.             }
  1670.           k--;
  1671.           continue;
  1672.         }
  1673.           if (vinds[k] < ARRAY_DIMS (ra)[k].ubnd)
  1674.         {
  1675.           vinds[k]++;
  1676.           k++;
  1677.           continue;
  1678.         }
  1679.           vinds[k] = ARRAY_DIMS (ra)[k].lbnd - 1;
  1680.           k--;
  1681.         }
  1682.       while (k >= 0);
  1683.       return UNSPECIFIED;
  1684.     }
  1685.       }
  1686. }
  1687.  
  1688. SCM scm_array_equal P ((SCM ra0, SCM ra1));
  1689. static int raeql_1 (ra0, as_equal, ra1)
  1690.      SCM ra0, as_equal, ra1;
  1691. {
  1692.   SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
  1693.   sizet i0 = 0, i1 = 0;
  1694.   long inc0 = 1, inc1 = 1;
  1695.   sizet n = LENGTH (ra0);
  1696.   ra1 = CAR (ra1);
  1697.   if ARRAYP
  1698.     (ra0)
  1699.       {
  1700.     n = ARRAY_DIMS (ra0)->ubnd - ARRAY_DIMS (ra0)->lbnd + 1;
  1701.     i0 = ARRAY_BASE (ra0);
  1702.     inc0 = ARRAY_DIMS (ra0)->inc;
  1703.     ra0 = ARRAY_V (ra0);
  1704.       }
  1705.   if ARRAYP
  1706.     (ra1)
  1707.       {
  1708.     i1 = ARRAY_BASE (ra1);
  1709.     inc1 = ARRAY_DIMS (ra1)->inc;
  1710.     ra1 = ARRAY_V (ra1);
  1711.       }
  1712.   switch TYP7
  1713.     (ra0)
  1714.       {
  1715.       case tc7_vector:
  1716.       default:
  1717.     for (; n--; i0 += inc0, i1 += inc1)
  1718.       {
  1719.         if FALSEP
  1720.           (as_equal)
  1721.         {
  1722.           if FALSEP
  1723.             (scm_array_equal (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
  1724.               return 0;
  1725.         }
  1726.         else if FALSEP
  1727.           (scm_equal (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
  1728.         return 0;
  1729.       }
  1730.     return 1;
  1731.       case tc7_string:
  1732.     {
  1733.       char *v0 = CHARS (ra0) + i0;
  1734.       char *v1 = CHARS (ra1) + i1;
  1735.       for (; n--; v0 += inc0, v1 += inc1)
  1736.         if (*v0 != *v1)
  1737.           return 0;
  1738.       return 1;
  1739.     }
  1740.       case tc7_bvect:
  1741.     for (; n--; i0 += inc0, i1 += inc1)
  1742.       if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
  1743.         return 0;
  1744.     return 1;
  1745.       case tc7_uvect:
  1746.       case tc7_ivect:
  1747.     {
  1748.       long *v0 = (long *) VELTS (ra0) + i0;
  1749.       long *v1 = (long *) VELTS (ra1) + i1;
  1750.       for (; n--; v0 += inc0, v1 += inc1)
  1751.         if (*v0 != *v1)
  1752.           return 0;
  1753.       return 1;
  1754.     }
  1755. #ifdef FLOATS
  1756. #ifdef SINGLES
  1757.       case tc7_fvect:
  1758.     {
  1759.       float *v0 = (float *) VELTS (ra0) + i0;
  1760.       float *v1 = (float *) VELTS (ra1) + i1;
  1761.       for (; n--; v0 += inc0, v1 += inc1)
  1762.         if (*v0 != *v1)
  1763.           return 0;
  1764.       return 1;
  1765.     }
  1766. #endif /* SINGLES */
  1767.       case tc7_dvect:
  1768.     {
  1769.       double *v0 = (double *) VELTS (ra0) + i0;
  1770.       double *v1 = (double *) VELTS (ra1) + i1;
  1771.       for (; n--; v0 += inc0, v1 += inc1)
  1772.         if (*v0 != *v1)
  1773.           return 0;
  1774.       return 1;
  1775.     }
  1776.       case tc7_cvect:
  1777.     {
  1778.       double (*v0)[2] = (double (*)[2]) VELTS (ra0) + i0;
  1779.       double (*v1)[2] = (double (*)[2]) VELTS (ra1) + i1;
  1780.       for (; n--; v0 += inc0, v1 += inc1)
  1781.         {
  1782.           if ((*v0)[0] != (*v1)[0])
  1783.         return 0;
  1784.           if ((*v0)[1] != (*v1)[1])
  1785.         return 0;
  1786.         }
  1787.       return 1;
  1788.     }
  1789. #endif /* FLOATS */
  1790.       }
  1791. }
  1792. static int raeql (ra0, as_equal, ra1)
  1793.      SCM ra0, as_equal, ra1;
  1794. {
  1795.   SCM v0 = ra0, v1 = ra1;
  1796.   scm_array_dim dim0, dim1;
  1797.   scm_array_dim *s0 = &dim0, *s1 = &dim1;
  1798.   sizet bas0 = 0, bas1 = 0;
  1799.   int k, unroll = 1, vlen = 1, ndim = 1;
  1800.   if ARRAYP
  1801.     (ra0)
  1802.       {
  1803.     ndim = ARRAY_NDIM (ra0);
  1804.     s0 = ARRAY_DIMS (ra0);
  1805.     bas0 = ARRAY_BASE (ra0);
  1806.     v0 = ARRAY_V (ra0);
  1807.       }
  1808.   else
  1809.     {
  1810.       s0->inc = 1;
  1811.       s0->lbnd = 0;
  1812.       s0->ubnd = LENGTH (v0) - 1;
  1813.       unroll = 0;
  1814.     }
  1815.   if ARRAYP
  1816.     (ra1)
  1817.       {
  1818.     if (ndim != ARRAY_NDIM (ra1))
  1819.       return 0;
  1820.     s1 = ARRAY_DIMS (ra1);
  1821.     bas1 = ARRAY_BASE (ra1);
  1822.     v1 = ARRAY_V (ra1);
  1823.       }
  1824.   else
  1825.     {
  1826.       if (1 != ndim)
  1827.     return BOOL_F;
  1828.       s1->inc = 1;
  1829.       s1->lbnd = 0;
  1830.       s1->ubnd = LENGTH (v1) - 1;
  1831.       unroll = 0;
  1832.     }
  1833.   if (TYP7 (v0) != TYP7 (v1))
  1834.     return 0;
  1835.   for (k = ndim; k--;)
  1836.     {
  1837.       if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
  1838.     return 0;
  1839.       if (unroll)
  1840.     {
  1841.       unroll = (s0[k].inc == s1[k].inc);
  1842.       vlen *= s0[k].ubnd - s1[k].lbnd + 1;
  1843.     }
  1844.     }
  1845.   if (unroll && bas0 == bas1 && v0 == v1)
  1846.     return BOOL_T;
  1847.   return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, EOL), "");
  1848. }
  1849.  
  1850. SCM scm_raequal (ra0, ra1)
  1851.      SCM ra0, ra1;
  1852. {
  1853.   return (raeql (ra0, BOOL_T, ra1) ? BOOL_T : BOOL_F);
  1854. }
  1855. static char s_array_equalp[] = "array-equal?";
  1856. SCM scm_array_equal (ra0, ra1)
  1857.      SCM ra0, ra1;
  1858. {
  1859.   if (IMP (ra0) || IMP (ra1))
  1860.   callequal:return scm_equal (ra0, ra1);
  1861.   switch TYP7
  1862.     (ra0)
  1863.       {
  1864.       default:
  1865.     goto callequal;
  1866.       case tc7_bvect:
  1867.       case tc7_string:
  1868.       case tc7_uvect:
  1869.       case tc7_ivect:
  1870.       case tc7_fvect:
  1871.       case tc7_dvect:
  1872.       case tc7_cvect:
  1873.       case tc7_vector:
  1874.     break;
  1875.       case tc7_smob:
  1876.     if (!ARRAYP (ra0))
  1877.       goto callequal;
  1878.       }
  1879.   switch TYP7
  1880.     (ra1)
  1881.       {
  1882.       default:
  1883.     goto callequal;
  1884.       case tc7_bvect:
  1885.       case tc7_string:
  1886.       case tc7_uvect:
  1887.       case tc7_ivect:
  1888.       case tc7_fvect:
  1889.       case tc7_dvect:
  1890.       case tc7_cvect:
  1891.       case tc7_vector:
  1892.     break;
  1893.       case tc7_smob:
  1894.     if (!ARRAYP (ra1))
  1895.       goto callequal;
  1896.       }
  1897.   return (raeql (ra0, BOOL_F, ra1) ? BOOL_T : BOOL_F);
  1898. }
  1899.  
  1900. static scm_iproc subr2s[] =
  1901. {
  1902.   {s_array_fill, scm_array_fill},
  1903.   {s_array_copy, scm_array_copy},
  1904.   {s_sarray_copy, scm_array_copy},
  1905.   {0, 0}};
  1906.  
  1907. static scm_iproc lsubr2s[] =
  1908. {
  1909.   {s_array_map, scm_array_map},
  1910.   {s_sarray_map, scm_array_map},
  1911.   {s_array_for_each, scm_array_for_each},
  1912.   {s_array_imap, scm_array_imap},
  1913.   {0, 0}};
  1914.  
  1915. static void init_raprocs (subra)
  1916.      ra_iproc *subra;
  1917. {
  1918.   for (; subra->name; subra++)
  1919.     subra->sproc = CDR (scm_intern (subra->name, strlen (subra->name)));
  1920. }
  1921.  
  1922. void scm_init_ramap ()
  1923. {
  1924.   init_raprocs (ra_rpsubrs);
  1925.   init_raprocs (ra_asubrs);
  1926.   scm_init_iprocs (subr2s, tc7_subr_2);
  1927.   scm_init_iprocs (lsubr2s, tc7_lsubr_2);
  1928.   scm_make_subr (s_array_equalp, tc7_rpsubr, scm_array_equal);
  1929.   scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
  1930.   scm_add_feature (s_array_for_each);
  1931. }
  1932.  
  1933. #endif /* ARRAYS */
  1934.